-----------------------------------------------------------------------------
-- |
-- Maintainer  :  Joost Visser
-- Stability   :  experimental
-- Portability :  portable
--
-- Parsing XML schemas.
--
-----------------------------------------------------------------------------

module Language.XMLSchema.Parse where

import Text.XML.HaXml.Parse
import Text.XML.HaXml.Xml2Haskell (fromElem)
import IO
import Text.XML.HaXml.Types

import StrategyLib

import Language.XMLSchema.NameSpaces 
        (Prefix,
         NameSpaceEnv(..),createNameSpaceEnv,xmlSchemaPrefixes,
         Schema, noExtension',getSchemaLocations)
         
import Text.Regex
import Debug.Trace

-----------------------------------------------------------------------------
-- * Import chasing

-- | Parse a single XSD file
parseXsdFile :: [FilePath] -> ChaseName -> IO (Either Schema String) 
parseXsdFile clspth relativeName = do
  -- putStrLn $ "Attempting to read: "++infile
  fileName <- findFile clspth (noExtension' relativeName) ["xsd"]
  fileContent <- readFile fileName
  -- putStrLn $ "Parsing "++fileName
  let (Document _ _ xmlElement) = xmlParse relativeName fileContent
  let nse = createNameSpaceEnv xmlElement 
  let xsPfxs = Prelude.filter (/="xs") $ xmlSchemaPrefixes nse
  -- putStrLn $ "Prefixes to be replaced: "++(show xsPfxs)
  let (_,xmlElement',nse')
        = reparseIfNeeded xsPfxs fileContent (relativeName,xmlElement,nse)
  let maybeSchema = (fst (fromElem [CElem xmlElement']))
  case maybeSchema of
    Nothing     -> return $ Right $ "Parse error in schema: "++relativeName
    (Just xs)   -> return $ Left (relativeName,xmlElement',xs,nse',fileName)

mytrace x 
 = trace ("[Trace] "++show x) x
 
xsdChaseImports :: [FilePath] -> [ChaseName] -> IO [Schema]
xsdChaseImports clspth clsnames
 = chaseWith clspth clsnames [] [] parse getImports onModule onMissing
 where
   parse = parseXsdFile
   getImports = getSchemaLocations
   onModule mn is m cus = return (m:cus)
   onMissing mn cus = return cus

-- | Replace given prefix by prefix "xs:", if appropriate.
--   Somewhat context-insensitive, i.e. might replace too much!
enforceXsPrefix "xs" fileContent = fileContent
enforceXsPrefix "" fileContent 
 = subRegex re fileContent "\\1xs:\\2"
 where
   -- re = mkRegex "(</? *)([a-zA-Z]+)"
   -- non-prefixed tag is closed by space, slash, angle or line terminator
   re = mkRegexWithOpts "(</? *)([a-zA-Z]+([ />]|([\r]?$)))" True True
enforceXsPrefix pfx fileContent 
 = subRegex re fileContent "\\1xs:\\2"
 where
   re = mkRegex $ "(</? *)"++pfx++":([a-zA-Z]+)"
   -- str'  = subRegex (mkRegex ("<"++pfx++":")) str "<xs:"
   -- str'' = subRegex (mkRegex ("</"++pfx++":")) str' "</xs:"

type RawSchema = (FilePath,Element,NameSpaceEnv)

reparseIfNeeded :: [Prefix] -> String -> RawSchema -> RawSchema
reparseIfNeeded [] fileContent (relativeName,xmlElement,nse) 
  = (relativeName,xmlElement,nse)
reparseIfNeeded pfxs fileContent (relativeName,xmlElement,nse)
  = (relativeName,xmlElement',nse)
  where
    fileContent' = foldr (\pfx fc -> enforceXsPrefix pfx fc) fileContent pfxs
    (Document _ _ xmlElement') 
      = {- trace msg $ -} xmlParse relativeName fileContent'
    msg = "New file content: \n"++fileContent'

-----------------------------------------------------------------------------
